FP Routines required:

:          P STACK   |  FP STACK
FLIT    (            |     -- )         push an in-line fp value to the fp stack
FLITERAL                                compile an fp value on the fp stack as an FLIT
>F      (            |     -- n )       convert a string in the input string to a
                                        fp value and place it on the fp stack
                                        If compiling compile the fp value as an FLIT

FVARIABLE                               create a fp variable
F!      (  addr --   |   n -- )         store fp value n beginning at address addr
F@      (  addr --   |     -- n )       fetch fp value from address addr

FCONSTANT                               create a fp constant
FVALUE                                  create a fp value
FTO     (       --   |   n -- )         load a fp value in an FVALUE
+FTO    (       --   |   n -- )         add fp value n to the specified FVALUE

FDUP    (       --   |   n -- n n )     duplicate top of fp stack
FDROP   (       --   |   n -- )         drop top of fp stack
FSWAP   (       --   | a b -- b a )     swap top two items on fp stack
FOVER   (       --   | a b -- a b a )   copy 2nd fp item to top of fp stack

F+      (       --   | a b -- a+b )     add fp values a and b
F-      (       --   | a b -- a-b )     subtract fp value b from fp value a
F*      (       --   | a b -- a*b )     multiply fp values a and b
F/      (       --   | a b -- a\b )     divide fp value a by fp value b
FNEGATE (       --   |   n -- -n )      negate the fp value on the fp stack

F=      (     -- t/f | a b -- )         return true if a=b else return false
F0=     (     -- t/f |   a -- )         return true if a=0.0 else return false
F0<     (     -- t/f |   a -- )         return true if a is negative else return false
F>      (     -- t/f | a b -- )         return true if a>b else return false
F<      (     -- t/f | a b -- )         return true if a<b else return false

S>FP    (     n --   |     -- n )       single to fp
FP>S    (       -- n |   n -- )         fp to single

F.      (       --   |   n -- )         display fp value n
.FS     (       --   |     -- )         non-destructively display fp stack
;



\ ---start of library code---

$8354 CONSTANT _fperr   \ addr of FP error byte in scratchpad
$834A CONSTANT _fac     \ address of _fac in scratchpad
$835C CONSTANT _arg     \ address of _arg in scratchpad
$837C CONSTANT _status  \ address of GPL status byte
$3420 CONSTANT _vdpwk   \ address of VDP work area
   10 CONSTANT _fpssz   \ max number of entries on FP stack
    0 VALUE    _fpsc    \ number of items on fp stack
CREATE _fpstack _fpssz 8 * ALLOT  \ floating point stack
CREATE _fptemp 8 CHARS ALLOT
CREATE _fpstr 12 CHARS ALLOT \ fp string buffer
     
\ internal routines 
HEX CODE: xmllnk 
C814 83E2 C520 83F6 02E0 83E0 C081 09C1 0A11 0A42 09B2 A0A1
0CFA C092 0692 02E0 8300 C814 83F6 0644 ;CODE

CODE: fixSP
C020 A010 0201 8348 0202 0022 04E0 6000 CC70 0642 16FD 04E0
6002 ;CODE

CODE: cns                                                       
04C0 C800 83C4 D800 837C D800 8355 C800 6000 C020 A00E 0410     
0014 04E0 6002 D020 8355 0880 0220 8300 D060 8356 04C2 D090     
0282 2000 1603 0580 0221 FF00 C094 0644 DC81 0881 DCB0 0601     
16FD ;CODE DECIMAL

: fpsc++ \ increase fp stack pointer
    _fpsc _fpssz = IF
        RP@ $.
        ." Floating point stack overflow" CR ABORT
    ELSE
        1 +TO _fpsc
    THEN
;

: fpsc-- \ decrease fp stack pointer
    _fpsc 0= IF 
        RP@ $.
        ." Floating point stack underflow" CR ABORT
    ELSE
        -1 +TO _fpsc
    THEN
;

: fpsaddr \ calculate fp stack address from fp stack pointer
    _fpstack _fpsc 8 * + ;

: vdpstr>fp \ convert string in VDP work area to fp number
    \ fp value placed in _fac
    _vdpwk _fac 12 + !  $1000 xmllnk ;
    
: fac>fpstack \ move a value from _fac to fp stack
    fpsc++ _fac fpsaddr 8 - 4 COPYW  ;
    
: fps>fac
    \ move a value from fp stack to _fac
    fpsc-- fpsaddr _fac 4 COPYW ;

: fps>arg \ move a value from fp stack to _arg
    fpsc-- fpsaddr _arg 4 COPYW ;

: VMBC ( VDPD VDPS CNT -- )
	0 DO DUP I + V@ 2 PICK I + V! LOOP 2DROP ;

: str>vdpwa \ move string in input stream to VDP work area
    _vdpwk BL WORD DUP >R BLK @ IF VMBC ELSE VMBW THEN
    0 _vdpwk R> + V! \ place a null at the end of the string
;



\ ---floating point stack manipulation---

: FDUP  ( ds: --  fs:n -- n n )
    fpsc++ fpsaddr 16 - fpsaddr 8 - 4 COPYW ;

: FDROP ( ds: --  fs:n -- )
    fpsc-- ;

: FSWAP ( ds: --  fs:a b -- b a )
    fpsaddr 8 - _fptemp 4 COPYW \ tos to temp
    fpsaddr 16 - fpsaddr 8 - 4 COPYW 
    _fptemp fpsaddr 16 - 4 COPYW 
;

: FOVER ( ds: --  fs:a b -- a b a )
    fpsc++ fpsaddr 24 - fpsaddr 8 - 4 COPYW ;

\ ---floating point math---

: F+ ( ds: --  fs:a b -- a+b )
    fps>fac fps>arg $0600 xmllnk fac>fpstack fixSP ;

: F- ( ds: --  fs:a b -- a-b )     
    fps>fac fps>arg $0700 xmllnk fac>fpstack fixSP ;

: F* ( ds: --  fs:a b -- a*b )     
    fps>fac fps>arg $0800 xmllnk fac>fpstack fixSP ;

: F/ ( ds: --  fs:a b -- a\b )
    fps>fac fps>arg $0900 xmllnk fac>fpstack fixSP ;

: FNEGATE ( ds: --  fs:n -- -n )
    FDUP FDUP F+ F- ;


\ ---Floating point literal handling ---

: FLIT
    \ copy the radix 100 string immediately after the FLIT
    \ opcode to fp stack
    \ addr on return stack points to payload copy it to fp stack
    R@ fpsaddr 4 COPYW fpsc++
    R> 8 + >R \ move return address past payload
;

: FLITERAL 
    COMPILE FLIT
    fpsc-- fpsaddr HERE 4 COPYW \ value on fp stack to HERE
    8 CHARS ALLOT \ advance HERE past the fp value
; IMMEDIATE
        
: >F
    \ If state=0:
    \   converts a number in the input stream to FP and places
    \   it on the FP stack
    \ If state=1:
    \   compiles FLIT and copies the radix 100 8-byte stream to HERE
    STATE @ IF
        \ we're compiling
        COMPILE FLIT \ compile reference to FLIT
        str>vdpwa    \ copy string in input stream to vdpwa
        vdpstr>fp    \ convert string in vdpwa to fp (in _fac)
        _fac HERE 4 COPYW \ move radix 100 string in _fac to here
        8 CHARS ALLOT \ move past the radix 100 string
    ELSE
        str>vdpwa
        vdpstr>fp fac>fpstack
    THEN
    fixSP
; IMMEDIATE


\ ---floating point comparison routines---
\ GPL Status byte:
\ | 0 |  1 |   2  |   3   |   4   | 5 | 6 | 7 |
\ | H | GT | COND | CARRY | OFLOW | 5 | 6 | 7 |
\
: F=  ( -- t/f | a b -- )
    fps>fac fps>arg
    $A00 xmllnk
    _status C@ %00100000 AND = IF TRUE ELSE FALSE THEN
    fixSP ;

: F0= ( -- t/f |   a -- )
    fpsc-- fpsaddr @ 0= IF TRUE ELSE FALSE THEN ;

: F<  ( -- t/f | a b -- )
    fps>arg fps>fac $A00 xmllnk
    _status C@ %01100000 AND 64 = IF TRUE ELSE FALSE THEN
    fixSP ;

: F>  ( -- t/f | a b -- )
    FSWAP F< ;

: F0< ( -- t/f |   a -- )
    >F 0 F< ;




    

\ ---floating point variable handling---
    
: FVARIABLE
    CREATE 8 CHARS ALLOT ;
    
: F! ( ds:address --  fs:n -- )
    fpsc-- fpsaddr SWAP 4 COPYW ;
    
: F@ ( ds:address --  fs: -- n )
    fpsaddr  4 COPYW  fpsc++ ;
    


\ ---floating point constant handling---
    
: FCONSTANT ( ds: --  fs: n -- )
    CREATE 8 CHARS ALLOT
    fpsc-- fpsaddr  HERE 8 -  4 COPYW
    DOES> fpsaddr 4 COPYW fpsc++ ;
    
: FVALUE ( ds: --  fs: n -- )
    FCONSTANT ;
    
: (FTO) ( body -- )
    fpsc-- fpsaddr SWAP 4 COPYW ;

: FTO ( ds: --  fs: n -- )
    \ set FP value to n. e.g: >F 3.141 FTO PI
    BL WORD FIND DROP >BODY \ address of r100 data
    STATE @ IF
        [COMPILE] LITERAL  COMPILE (FTO)
    ELSE
        (FTO)
    THEN
; IMMEDIATE

: (+FTO) ( body -- )
    DUP \ dup body addr
    fpsaddr 4 COPYW fpsc++ \ move the r100 value in the body to fp stack
    F+ \ perform addition
    fpsc-- fpsaddr SWAP 4 COPYW \ copy result to body
;  

: +FTO ( ds: --  fs: n -- )
    \ the fp value n is added to the fp FVALUE
    BL WORD FIND DROP >BODY
    STATE @ IF
        [COMPILE] LITERAL  COMPILE (+FTO)
    ELSE
        (+FTO)
    THEN
; IMMEDIATE
    

    
\ ---floating point display routines---

: F. ( ds: --  fs: n -- )
    \ display the top fp number in decimal
    fps>fac     \ top of fp stack to _fac
    _fpstr      \ address of string buffer
    cns         \ convert fp number to string
    fixSP       \ restore scratch-pad memory
    _fpstr COUNT TYPE \ display it
;

: .FS ( ds: --  fs: -- )
    \ non-destructively display the contents of the fp stack
    _fpsc 0> IF
        _fpstack
        _fpsc 0 DO
            DUP _fac 4 COPYW \ copy stack value to _fac
            _fpstr  \ address of fp string buffer
            cns     \ convert fp number in _fac to string
            fixSP   \ restore scratch-pad
            _fpstr COUNT TYPE SPACE
            8 +
        LOOP DROP ." <--TOP" CR
    ELSE
        ." Empty "
    THEN
;

: S>FP ( ds: n --  fs: -- n )
    \ convert single to floating point number
    N>S \ convert single to string
    DUP >R \ save string length
    _vdpwk -ROT VMBW \ copy to vdp work area
    0 R> _vdpwk + V! \ write a null to end of string

    vdpstr>fp       \ convert string in vdpwa to fp (in _fac)
    fac>fpstack     \ place on stack
    fixSP           \ restore scratch-pad memory
;

: FP>S    ( ds: -- n  fs: n -- )
    fps>fac $1200 xmllnk $834A @ fixSP ;

\ ---end of library code---










\ ASSEMBLY ROUTINES (already coded into CODE: words, above)
ASM: xmllnk
    *SP $83E2 @@ MOV,   \ move XML opcode to R1 in GPL workspace
    $83F6 @@ *SP MOV,   \ save GPLs R11 on stack
    $83E0 LWPI,         \ load GPL workspace
    R1 R2 MOV,          \ copy opcode
    R1 12 SRL,          \ get table number only
    R1 1 SLA,           \ convert to offset
    R2 4 SLA,           \ remove table number from copy
    R2 11 SRL,          \ get index into table
    $0CFA R1 () R2 A,   \ get address of pointer
    R2 ** R2 MOV,       \ get address of code
    R2 ** BL,           \ branch to the code
    $8300 LWPI,         \ restore TF workspace
    *SP $83F6 @@ MOV,   \ restore GPLs R11 from stack
    SP DECT,            \ pop stack
;ASM

ASM: fixSP \ restore scratchpad memory
    $A010 @@ R0 MOV,    \ scratchpad restore code vector
    R1 $8348 LI,        \ destination address
    R2 34 LI,           \ count
    $6000 @@ CLR,       \ select bank 1
    BEGIN,
        R0 *+ R1 *+ MOV, \ copy the code from bank 1 to spad
        R2 DECT,
    EQ UNTIL,
    $6002 @@ CLR,       \ select bank 0
;ASM

ASM: cns
    \ convert number to string
    R0 CLR,
    R0 $83C4 @@ MOV,    \ disable user ISR
    R0 $837C @@ MOVB,   \ clear GPL status byte
    R0 $834A 11 + @@ MOVB, \ TI BASIC format

    R0 $6000 @@ MOV,    \ select bank 1    
    $A00E @@ R0 MOV,    \ address of GPLLNK VECTOR
    R0 ** BLWP,         \ call GPLLNK
    $0014 ,             \ CNS opcode
    $6002 @@ CLR,       \ select bank 0

    $834A 11 + @@ R0 MOVB, \ address low byte
    R0 8 SRA,           \ move to low byte
    R0 $8300 AI,        \ convert to real address

    $834A 12 + @@ R1 MOVB, \ get string length
    
    R2 CLR,
    R0 ** R2 MOVB,      \ examine 1st char of string
    R2 32 256 * CI,     \ is it a space?
    EQ IF,
        R0 INC,         \ move past leading space
        R1 -256 AI,     \ account for leading space
    ENDIF,

    *SP R2 MOV,         \ address of string buffer
    SP DECT,            \ pop stack
    
    R1 R2 *+ MOVB,      \ write string length to string buffer
    R1 8 SRA,           \ move string length to low byte

    BEGIN,
        R0 *+ R2 *+ MOVB, \ move a byte of string data
        R1 DEC,         \ decrement counter
    EQ UNTIL,
;ASM



